home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-9.10-netbook-remix-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / HTTP / Daemon.pm < prev    next >
Text File  |  2009-06-15  |  23KB  |  904 lines
  1. package HTTP::Daemon;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA $PROTO $DEBUG);
  5.  
  6. $VERSION = "5.827";
  7.  
  8. use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
  9. @ISA=qw(IO::Socket::INET);
  10.  
  11. $PROTO = "HTTP/1.1";
  12.  
  13.  
  14. sub new
  15. {
  16.     my($class, %args) = @_;
  17.     $args{Listen} ||= 5;
  18.     $args{Proto}  ||= 'tcp';
  19.     return $class->SUPER::new(%args);
  20. }
  21.  
  22.  
  23. sub accept
  24. {
  25.     my $self = shift;
  26.     my $pkg = shift || "HTTP::Daemon::ClientConn";
  27.     my ($sock, $peer) = $self->SUPER::accept($pkg);
  28.     if ($sock) {
  29.         ${*$sock}{'httpd_daemon'} = $self;
  30.         return wantarray ? ($sock, $peer) : $sock;
  31.     }
  32.     else {
  33.         return;
  34.     }
  35. }
  36.  
  37.  
  38. sub url
  39. {
  40.     my $self = shift;
  41.     my $url = $self->_default_scheme . "://";
  42.     my $addr = $self->sockaddr;
  43.     if (!$addr || $addr eq INADDR_ANY) {
  44.      require Sys::Hostname;
  45.      $url .= lc Sys::Hostname::hostname();
  46.     }
  47.     else {
  48.     $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
  49.     }
  50.     my $port = $self->sockport;
  51.     $url .= ":$port" if $port != $self->_default_port;
  52.     $url .= "/";
  53.     $url;
  54. }
  55.  
  56.  
  57. sub _default_port {
  58.     80;
  59. }
  60.  
  61.  
  62. sub _default_scheme {
  63.     "http";
  64. }
  65.  
  66.  
  67. sub product_tokens
  68. {
  69.     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  70. }
  71.  
  72.  
  73.  
  74. package HTTP::Daemon::ClientConn;
  75.  
  76. use vars qw(@ISA $DEBUG);
  77. use IO::Socket ();
  78. @ISA=qw(IO::Socket::INET);
  79. *DEBUG = \$HTTP::Daemon::DEBUG;
  80.  
  81. use HTTP::Request  ();
  82. use HTTP::Response ();
  83. use HTTP::Status;
  84. use HTTP::Date qw(time2str);
  85. use LWP::MediaTypes qw(guess_media_type);
  86. use Carp ();
  87.  
  88. my $CRLF = "\015\012";   # "\r\n" is not portable
  89. my $HTTP_1_0 = _http_version("HTTP/1.0");
  90. my $HTTP_1_1 = _http_version("HTTP/1.1");
  91.  
  92.  
  93. sub get_request
  94. {
  95.     my($self, $only_headers) = @_;
  96.     if (${*$self}{'httpd_nomore'}) {
  97.         $self->reason("No more requests from this connection");
  98.     return;
  99.     }
  100.  
  101.     $self->reason("");
  102.     my $buf = ${*$self}{'httpd_rbuf'};
  103.     $buf = "" unless defined $buf;
  104.  
  105.     my $timeout = $ {*$self}{'io_socket_timeout'};
  106.     my $fdset = "";
  107.     vec($fdset, $self->fileno, 1) = 1;
  108.     local($_);
  109.  
  110.   READ_HEADER:
  111.     while (1) {
  112.     # loop until we have the whole header in $buf
  113.     $buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
  114.     if ($buf =~ /\012/) {  # potential, has at least one line
  115.         if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
  116.         if ($buf =~ /\015?\012\015?\012/) {
  117.             last READ_HEADER;  # we have it
  118.         }
  119.         elsif (length($buf) > 16*1024) {
  120.             $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
  121.             $self->reason("Very long header");
  122.             return;
  123.         }
  124.         }
  125.         else {
  126.         last READ_HEADER;  # HTTP/0.9 client
  127.         }
  128.     }
  129.     elsif (length($buf) > 16*1024) {
  130.         $self->send_error(414); # REQUEST_URI_TOO_LARGE
  131.         $self->reason("Very long first line");
  132.         return;
  133.     }
  134.     print STDERR "Need more data for complete header\n" if $DEBUG;
  135.     return unless $self->_need_more($buf, $timeout, $fdset);
  136.     }
  137.     if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
  138.     ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
  139.     $self->send_error(400);  # BAD_REQUEST
  140.     $self->reason("Bad request line: $buf");
  141.     return;
  142.     }
  143.     my $method = $1;
  144.     my $uri = $2;
  145.     my $proto = $3 || "HTTP/0.9";
  146.     $uri = "http://$uri" if $method eq "CONNECT";
  147.     $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
  148.     my $r = HTTP::Request->new($method, $uri);
  149.     $r->protocol($proto);
  150.     ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
  151.     ${*$self}{'httpd_head'} = ($method eq "HEAD");
  152.  
  153.     if ($proto >= $HTTP_1_0) {
  154.     # we expect to find some headers
  155.     my($key, $val);
  156.       HEADER:
  157.     while ($buf =~ s/^([^\012]*)\012//) {
  158.         $_ = $1;
  159.         s/\015$//;
  160.         if (/^([^:\s]+)\s*:\s*(.*)/) {
  161.         $r->push_header($key, $val) if $key;
  162.         ($key, $val) = ($1, $2);
  163.         }
  164.         elsif (/^\s+(.*)/) {
  165.         $val .= " $1";
  166.         }
  167.         else {
  168.         last HEADER;
  169.         }
  170.     }
  171.     $r->push_header($key, $val) if $key;
  172.     }
  173.  
  174.     my $conn = $r->header('Connection');
  175.     if ($proto >= $HTTP_1_1) {
  176.     ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
  177.     }
  178.     else {
  179.     ${*$self}{'httpd_nomore'}++ unless $conn &&
  180.                                            lc($conn) =~ /\bkeep-alive\b/;
  181.     }
  182.  
  183.     if ($only_headers) {
  184.     ${*$self}{'httpd_rbuf'} = $buf;
  185.         return $r;
  186.     }
  187.  
  188.     # Find out how much content to read
  189.     my $te  = $r->header('Transfer-Encoding');
  190.     my $ct  = $r->header('Content-Type');
  191.     my $len = $r->header('Content-Length');
  192.  
  193.     # Act on the Expect header, if it's there
  194.     for my $e ( $r->header('Expect') ) {
  195.         if( lc($e) eq '100-continue' ) {
  196.             $self->send_status_line(100);
  197.             $self->send_crlf;
  198.         }
  199.         else {
  200.             $self->send_error(417);
  201.             $self->reason("Unsupported Expect header value");
  202.             return;
  203.         }
  204.     }
  205.  
  206.     if ($te && lc($te) eq 'chunked') {
  207.     # Handle chunked transfer encoding
  208.     my $body = "";
  209.       CHUNK:
  210.     while (1) {
  211.         print STDERR "Chunked\n" if $DEBUG;
  212.         if ($buf =~ s/^([^\012]*)\012//) {
  213.         my $chunk_head = $1;
  214.         unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
  215.             $self->send_error(400);
  216.             $self->reason("Bad chunk header $chunk_head");
  217.             return;
  218.         }
  219.         my $size = hex($1);
  220.         last CHUNK if $size == 0;
  221.  
  222.         my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
  223.         # must read until we have a complete chunk
  224.         while ($missing > 0) {
  225.             print STDERR "Need $missing more bytes\n" if $DEBUG;
  226.             my $n = $self->_need_more($buf, $timeout, $fdset);
  227.             return unless $n;
  228.             $missing -= $n;
  229.         }
  230.         $body .= substr($buf, 0, $size);
  231.         substr($buf, 0, $size+2) = '';
  232.  
  233.         }
  234.         else {
  235.         # need more data in order to have a complete chunk header
  236.         return unless $self->_need_more($buf, $timeout, $fdset);
  237.         }
  238.     }
  239.     $r->content($body);
  240.  
  241.     # pretend it was a normal entity body
  242.     $r->remove_header('Transfer-Encoding');
  243.     $r->header('Content-Length', length($body));
  244.  
  245.     my($key, $val);
  246.       FOOTER:
  247.     while (1) {
  248.         if ($buf !~ /\012/) {
  249.         # need at least one line to look at
  250.         return unless $self->_need_more($buf, $timeout, $fdset);
  251.         }
  252.         else {
  253.         $buf =~ s/^([^\012]*)\012//;
  254.         $_ = $1;
  255.         s/\015$//;
  256.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  257.             $r->push_header($key, $val) if $key;
  258.             ($key, $val) = ($1, $2);
  259.         }
  260.         elsif (/^\s+(.*)/) {
  261.             $val .= " $1";
  262.         }
  263.         elsif (!length) {
  264.             last FOOTER;
  265.         }
  266.         else {
  267.             $self->reason("Bad footer syntax");
  268.             return;
  269.         }
  270.         }
  271.     }
  272.     $r->push_header($key, $val) if $key;
  273.  
  274.     }
  275.     elsif ($te) {
  276.     $self->send_error(501);     # Unknown transfer encoding
  277.     $self->reason("Unknown transfer encoding '$te'");
  278.     return;
  279.  
  280.     }
  281.     elsif ($len) {
  282.     # Plain body specified by "Content-Length"
  283.     my $missing = $len - length($buf);
  284.     while ($missing > 0) {
  285.         print "Need $missing more bytes of content\n" if $DEBUG;
  286.         my $n = $self->_need_more($buf, $timeout, $fdset);
  287.         return unless $n;
  288.         $missing -= $n;
  289.     }
  290.     if (length($buf) > $len) {
  291.         $r->content(substr($buf,0,$len));
  292.         substr($buf, 0, $len) = '';
  293.     }
  294.     else {
  295.         $r->content($buf);
  296.         $buf='';
  297.     }
  298.     }
  299.     elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
  300.     # Handle multipart content type
  301.     my $boundary = "$CRLF--$2--";
  302.     my $index;
  303.     while (1) {
  304.         $index = index($buf, $boundary);
  305.         last if $index >= 0;
  306.         # end marker not yet found
  307.         return unless $self->_need_more($buf, $timeout, $fdset);
  308.     }
  309.     $index += length($boundary);
  310.     $r->content(substr($buf, 0, $index));
  311.     substr($buf, 0, $index) = '';
  312.  
  313.     }
  314.     ${*$self}{'httpd_rbuf'} = $buf;
  315.  
  316.     $r;
  317. }
  318.  
  319.  
  320. sub _need_more
  321. {
  322.     my $self = shift;
  323.     #my($buf,$timeout,$fdset) = @_;
  324.     if ($_[1]) {
  325.     my($timeout, $fdset) = @_[1,2];
  326.     print STDERR "select(,,,$timeout)\n" if $DEBUG;
  327.     my $n = select($fdset,undef,undef,$timeout);
  328.     unless ($n) {
  329.         $self->reason(defined($n) ? "Timeout" : "select: $!");
  330.         return;
  331.     }
  332.     }
  333.     print STDERR "sysread()\n" if $DEBUG;
  334.     my $n = sysread($self, $_[0], 2048, length($_[0]));
  335.     $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
  336.     $n;
  337. }
  338.  
  339.  
  340. sub read_buffer
  341. {
  342.     my $self = shift;
  343.     my $old = ${*$self}{'httpd_rbuf'};
  344.     if (@_) {
  345.     ${*$self}{'httpd_rbuf'} = shift;
  346.     }
  347.     $old;
  348. }
  349.  
  350.  
  351. sub reason
  352. {
  353.     my $self = shift;
  354.     my $old = ${*$self}{'httpd_reason'};
  355.     if (@_) {
  356.         ${*$self}{'httpd_reason'} = shift;
  357.     }
  358.     $old;
  359. }
  360.  
  361.  
  362. sub proto_ge
  363. {
  364.     my $self = shift;
  365.     ${*$self}{'httpd_client_proto'} >= _http_version(shift);
  366. }
  367.  
  368.  
  369. sub _http_version
  370. {
  371.     local($_) = shift;
  372.     return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
  373.     $1 * 1000 + $2;
  374. }
  375.  
  376.  
  377. sub antique_client
  378. {
  379.     my $self = shift;
  380.     ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
  381. }
  382.  
  383.  
  384. sub force_last_request
  385. {
  386.     my $self = shift;
  387.     ${*$self}{'httpd_nomore'}++;
  388. }
  389.  
  390. sub head_request
  391. {
  392.     my $self = shift;
  393.     ${*$self}{'httpd_head'};
  394. }
  395.  
  396.  
  397. sub send_status_line
  398. {
  399.     my($self, $status, $message, $proto) = @_;
  400.     return if $self->antique_client;
  401.     $status  ||= RC_OK;
  402.     $message ||= status_message($status) || "";
  403.     $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
  404.     print $self "$proto $status $message$CRLF";
  405. }
  406.  
  407.  
  408. sub send_crlf
  409. {
  410.     my $self = shift;
  411.     print $self $CRLF;
  412. }
  413.  
  414.  
  415. sub send_basic_header
  416. {
  417.     my $self = shift;
  418.     return if $self->antique_client;
  419.     $self->send_status_line(@_);
  420.     print $self "Date: ", time2str(time), $CRLF;
  421.     my $product = $self->daemon->product_tokens;
  422.     print $self "Server: $product$CRLF" if $product;
  423. }
  424.  
  425.  
  426. sub send_header
  427. {
  428.     my $self = shift;
  429.     while (@_) {
  430.     my($k, $v) = splice(@_, 0, 2);
  431.     $v = "" unless defined($v);
  432.     print $self "$k: $v$CRLF";
  433.     }
  434. }
  435.  
  436.  
  437. sub send_response
  438. {
  439.     my $self = shift;
  440.     my $res = shift;
  441.     if (!ref $res) {
  442.     $res ||= RC_OK;
  443.     $res = HTTP::Response->new($res, @_);
  444.     }
  445.     my $content = $res->content;
  446.     my $chunked;
  447.     unless ($self->antique_client) {
  448.     my $code = $res->code;
  449.     $self->send_basic_header($code, $res->message, $res->protocol);
  450.     if ($code =~ /^(1\d\d|[23]04)$/) {
  451.         # make sure content is empty
  452.         $res->remove_header("Content-Length");
  453.         $content = "";
  454.     }
  455.     elsif ($res->request && $res->request->method eq "HEAD") {
  456.         # probably OK
  457.     }
  458.     elsif (ref($content) eq "CODE") {
  459.         if ($self->proto_ge("HTTP/1.1")) {
  460.         $res->push_header("Transfer-Encoding" => "chunked");
  461.         $chunked++;
  462.         }
  463.         else {
  464.         $self->force_last_request;
  465.         }
  466.     }
  467.     elsif (length($content)) {
  468.         $res->header("Content-Length" => length($content));
  469.     }
  470.     else {
  471.         $self->force_last_request;
  472.             $res->header('connection','close'); 
  473.     }
  474.     print $self $res->headers_as_string($CRLF);
  475.     print $self $CRLF;  # separates headers and content
  476.     }
  477.     if ($self->head_request) {
  478.     # no content
  479.     }
  480.     elsif (ref($content) eq "CODE") {
  481.     while (1) {
  482.         my $chunk = &$content();
  483.         last unless defined($chunk) && length($chunk);
  484.         if ($chunked) {
  485.         printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
  486.         }
  487.         else {
  488.         print $self $chunk;
  489.         }
  490.     }
  491.     print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
  492.     }
  493.     elsif (length $content) {
  494.     print $self $content;
  495.     }
  496. }
  497.  
  498.  
  499. sub send_redirect
  500. {
  501.     my($self, $loc, $status, $content) = @_;
  502.     $status ||= RC_MOVED_PERMANENTLY;
  503.     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  504.     $self->send_basic_header($status);
  505.     my $base = $self->daemon->url;
  506.     $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
  507.     $loc = $loc->abs($base);
  508.     print $self "Location: $loc$CRLF";
  509.     if ($content) {
  510.     my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  511.     print $self "Content-Type: $ct$CRLF";
  512.     }
  513.     print $self $CRLF;
  514.     print $self $content if $content && !$self->head_request;
  515.     $self->force_last_request;  # no use keeping the connection open
  516. }
  517.  
  518.  
  519. sub send_error
  520. {
  521.     my($self, $status, $error) = @_;
  522.     $status ||= RC_BAD_REQUEST;
  523.     Carp::croak("Status '$status' is not an error") unless is_error($status);
  524.     my $mess = status_message($status);
  525.     $error  ||= "";
  526.     $mess = <<EOT;
  527. <title>$status $mess</title>
  528. <h1>$status $mess</h1>
  529. $error
  530. EOT
  531.     unless ($self->antique_client) {
  532.         $self->send_basic_header($status);
  533.         print $self "Content-Type: text/html$CRLF";
  534.     print $self "Content-Length: " . length($mess) . $CRLF;
  535.         print $self $CRLF;
  536.     }
  537.     print $self $mess unless $self->head_request;
  538.     $status;
  539. }
  540.  
  541.  
  542. sub send_file_response
  543. {
  544.     my($self, $file) = @_;
  545.     if (-d $file) {
  546.     $self->send_dir($file);
  547.     }
  548.     elsif (-f _) {
  549.     # plain file
  550.     local(*F);
  551.     sysopen(F, $file, 0) or 
  552.       return $self->send_error(RC_FORBIDDEN);
  553.     binmode(F);
  554.     my($ct,$ce) = guess_media_type($file);
  555.     my($size,$mtime) = (stat _)[7,9];
  556.     unless ($self->antique_client) {
  557.         $self->send_basic_header;
  558.         print $self "Content-Type: $ct$CRLF";
  559.         print $self "Content-Encoding: $ce$CRLF" if $ce;
  560.         print $self "Content-Length: $size$CRLF" if $size;
  561.         print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
  562.         print $self $CRLF;
  563.     }
  564.     $self->send_file(\*F) unless $self->head_request;
  565.     return RC_OK;
  566.     }
  567.     else {
  568.     $self->send_error(RC_NOT_FOUND);
  569.     }
  570. }
  571.  
  572.  
  573. sub send_dir
  574. {
  575.     my($self, $dir) = @_;
  576.     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  577.     $self->send_error(RC_NOT_IMPLEMENTED);
  578. }
  579.  
  580.  
  581. sub send_file
  582. {
  583.     my($self, $file) = @_;
  584.     my $opened = 0;
  585.     local(*FILE);
  586.     if (!ref($file)) {
  587.     open(FILE, $file) || return undef;
  588.     binmode(FILE);
  589.     $file = \*FILE;
  590.     $opened++;
  591.     }
  592.     my $cnt = 0;
  593.     my $buf = "";
  594.     my $n;
  595.     while ($n = sysread($file, $buf, 8*1024)) {
  596.     last if !$n;
  597.     $cnt += $n;
  598.     print $self $buf;
  599.     }
  600.     close($file) if $opened;
  601.     $cnt;
  602. }
  603.  
  604.  
  605. sub daemon
  606. {
  607.     my $self = shift;
  608.     ${*$self}{'httpd_daemon'};
  609. }
  610.  
  611.  
  612. 1;
  613.  
  614. __END__
  615.  
  616. =head1 NAME
  617.  
  618. HTTP::Daemon - a simple http server class
  619.  
  620. =head1 SYNOPSIS
  621.  
  622.   use HTTP::Daemon;
  623.   use HTTP::Status;
  624.  
  625.   my $d = HTTP::Daemon->new || die;
  626.   print "Please contact me at: <URL:", $d->url, ">\n";
  627.   while (my $c = $d->accept) {
  628.       while (my $r = $c->get_request) {
  629.       if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
  630.               # remember, this is *not* recommended practice :-)
  631.           $c->send_file_response("/etc/passwd");
  632.       }
  633.       else {
  634.           $c->send_error(RC_FORBIDDEN)
  635.       }
  636.       }
  637.       $c->close;
  638.       undef($c);
  639.   }
  640.  
  641. =head1 DESCRIPTION
  642.  
  643. Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
  644. listen on a socket for incoming requests. The C<HTTP::Daemon> is a
  645. subclass of C<IO::Socket::INET>, so you can perform socket operations
  646. directly on it too.
  647.  
  648. The accept() method will return when a connection from a client is
  649. available.  The returned value will be an C<HTTP::Daemon::ClientConn>
  650. object which is another C<IO::Socket::INET> subclass.  Calling the
  651. get_request() method on this object will read data from the client and
  652. return an C<HTTP::Request> object.  The ClientConn object also provide
  653. methods to send back various responses.
  654.  
  655. This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  656. user of the C<HTTP::Daemon> is responsible for forking if that is
  657. desirable.  Also note that the user is responsible for generating
  658. responses that conform to the HTTP/1.1 protocol.
  659.  
  660. The following methods of C<HTTP::Daemon> are new (or enhanced) relative
  661. to the C<IO::Socket::INET> base class:
  662.  
  663. =over 4
  664.  
  665. =item $d = HTTP::Daemon->new
  666.  
  667. =item $d = HTTP::Daemon->new( %opts )
  668.  
  669. The constructor method takes the same arguments as the
  670. C<IO::Socket::INET> constructor, but unlike its base class it can also
  671. be called without any arguments.  The daemon will then set up a listen
  672. queue of 5 connections and allocate some random port number.
  673.  
  674. A server that wants to bind to some specific address on the standard
  675. HTTP port will be constructed like this:
  676.  
  677.   $d = HTTP::Daemon->new(
  678.            LocalAddr => 'www.thisplace.com',
  679.            LocalPort => 80,
  680.        );
  681.  
  682. See L<IO::Socket::INET> for a description of other arguments that can
  683. be used configure the daemon during construction.
  684.  
  685. =item $c = $d->accept
  686.  
  687. =item $c = $d->accept( $pkg )
  688.  
  689. =item ($c, $peer_addr) = $d->accept
  690.  
  691. This method works the same the one provided by the base class, but it
  692. returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
  693. package name is provided as argument, then the returned object will be
  694. blessed into the given class.  It is probably a good idea to make that
  695. class a subclass of C<HTTP::Daemon::ClientConn>.
  696.  
  697. The accept method will return C<undef> if timeouts have been enabled
  698. and no connection is made within the given time.  The timeout() method
  699. is described in L<IO::Socket>.
  700.  
  701. In list context both the client object and the peer address will be
  702. returned; see the description of the accept method L<IO::Socket> for
  703. details.
  704.  
  705. =item $d->url
  706.  
  707. Returns a URL string that can be used to access the server root.
  708.  
  709. =item $d->product_tokens
  710.  
  711. Returns the name that this server will use to identify itself.  This
  712. is the string that is sent with the C<Server> response header.  The
  713. main reason to have this method is that subclasses can override it if
  714. they want to use another product name.
  715.  
  716. The default is the string "libwww-perl-daemon/#.##" where "#.##" is
  717. replaced with the version number of this module.
  718.  
  719. =back
  720.  
  721. The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
  722. subclass. Instances of this class are returned by the accept() method
  723. of C<HTTP::Daemon>.  The following methods are provided:
  724.  
  725. =over 4
  726.  
  727. =item $c->get_request
  728.  
  729. =item $c->get_request( $headers_only )
  730.  
  731. This method reads data from the client and turns it into an
  732. C<HTTP::Request> object which is returned.  It returns C<undef>
  733. if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
  734. object ($c) should be discarded, and you should not try call this
  735. method again on it.  The $c->reason method might give you some
  736. information about why $c->get_request failed.
  737.  
  738. The get_request() method will normally not return until the whole
  739. request has been received from the client.  This might not be what you
  740. want if the request is an upload of a large file (and with chunked
  741. transfer encoding HTTP can even support infinite request messages -
  742. uploading live audio for instance).  If you pass a TRUE value as the
  743. $headers_only argument, then get_request() will return immediately
  744. after parsing the request headers and you are responsible for reading
  745. the rest of the request content.  If you are going to call
  746. $c->get_request again on the same connection you better read the
  747. correct number of bytes.
  748.  
  749. =item $c->read_buffer
  750.  
  751. =item $c->read_buffer( $new_value )
  752.  
  753. Bytes read by $c->get_request, but not used are placed in the I<read
  754. buffer>.  The next time $c->get_request is called it will consume the
  755. bytes in this buffer before reading more data from the network
  756. connection itself.  The read buffer is invalid after $c->get_request
  757. has failed.
  758.  
  759. If you handle the reading of the request content yourself you need to
  760. empty this buffer before you read more and you need to place
  761. unconsumed bytes here.  You also need this buffer if you implement
  762. services like I<101 Switching Protocols>.
  763.  
  764. This method always returns the old buffer content and can optionally
  765. replace the buffer content if you pass it an argument.
  766.  
  767. =item $c->reason
  768.  
  769. When $c->get_request returns C<undef> you can obtain a short string
  770. describing why it happened by calling $c->reason.
  771.  
  772. =item $c->proto_ge( $proto )
  773.  
  774. Return TRUE if the client announced a protocol with version number
  775. greater or equal to the given argument.  The $proto argument can be a
  776. string like "HTTP/1.1" or just "1.1".
  777.  
  778. =item $c->antique_client
  779.  
  780. Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
  781. code and no headers should be returned to such a client.  This should
  782. be the same as !$c->proto_ge("HTTP/1.0").
  783.  
  784. =item $c->head_request
  785.  
  786. Return TRUE if the last request was a C<HEAD> request.  No content
  787. body must be generated for these requests.
  788.  
  789. =item $c->force_last_request
  790.  
  791. Make sure that $c->get_request will not try to read more requests off
  792. this connection.  If you generate a response that is not self
  793. delimiting, then you should signal this fact by calling this method.
  794.  
  795. This attribute is turned on automatically if the client announces
  796. protocol HTTP/1.0 or worse and does not include a "Connection:
  797. Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
  798. or better clients send the "Connection: close" request header.
  799.  
  800. =item $c->send_status_line
  801.  
  802. =item $c->send_status_line( $code )
  803.  
  804. =item $c->send_status_line( $code, $mess )
  805.  
  806. =item $c->send_status_line( $code, $mess, $proto )
  807.  
  808. Send the status line back to the client.  If $code is omitted 200 is
  809. assumed.  If $mess is omitted, then a message corresponding to $code
  810. is inserted.  If $proto is missing the content of the
  811. $HTTP::Daemon::PROTO variable is used.
  812.  
  813. =item $c->send_crlf
  814.  
  815. Send the CRLF sequence to the client.
  816.  
  817. =item $c->send_basic_header
  818.  
  819. =item $c->send_basic_header( $code )
  820.  
  821. =item $c->send_basic_header( $code, $mess )
  822.  
  823. =item $c->send_basic_header( $code, $mess, $proto )
  824.  
  825. Send the status line and the "Date:" and "Server:" headers back to
  826. the client.  This header is assumed to be continued and does not end
  827. with an empty CRLF line.
  828.  
  829. See the description of send_status_line() for the description of the
  830. accepted arguments.
  831.  
  832. =item $c->send_header( $field, $value )
  833.  
  834. =item $c->send_header( $field1, $value1, $field2, $value2, ... )
  835.  
  836. Send one or more header lines.
  837.  
  838. =item $c->send_response( $res )
  839.  
  840. Write a C<HTTP::Response> object to the
  841. client as a response.  We try hard to make sure that the response is
  842. self delimiting so that the connection can stay persistent for further
  843. request/response exchanges.
  844.  
  845. The content attribute of the C<HTTP::Response> object can be a normal
  846. string or a subroutine reference.  If it is a subroutine, then
  847. whatever this callback routine returns is written back to the
  848. client as the response content.  The routine will be called until it
  849. return an undefined or empty value.  If the client is HTTP/1.1 aware
  850. then we will use chunked transfer encoding for the response.
  851.  
  852. =item $c->send_redirect( $loc )
  853.  
  854. =item $c->send_redirect( $loc, $code )
  855.  
  856. =item $c->send_redirect( $loc, $code, $entity_body )
  857.  
  858. Send a redirect response back to the client.  The location ($loc) can
  859. be an absolute or relative URL. The $code must be one the redirect
  860. status codes, and defaults to "301 Moved Permanently"
  861.  
  862. =item $c->send_error
  863.  
  864. =item $c->send_error( $code )
  865.  
  866. =item $c->send_error( $code, $error_message )
  867.  
  868. Send an error response back to the client.  If the $code is missing a
  869. "Bad Request" error is reported.  The $error_message is a string that
  870. is incorporated in the body of the HTML entity body.
  871.  
  872. =item $c->send_file_response( $filename )
  873.  
  874. Send back a response with the specified $filename as content.  If the
  875. file is a directory we try to generate an HTML index of it.
  876.  
  877. =item $c->send_file( $filename )
  878.  
  879. =item $c->send_file( $fd )
  880.  
  881. Copy the file to the client.  The file can be a string (which
  882. will be interpreted as a filename) or a reference to an C<IO::Handle>
  883. or glob.
  884.  
  885. =item $c->daemon
  886.  
  887. Return a reference to the corresponding C<HTTP::Daemon> object.
  888.  
  889. =back
  890.  
  891. =head1 SEE ALSO
  892.  
  893. RFC 2616
  894.  
  895. L<IO::Socket::INET>, L<IO::Socket>
  896.  
  897. =head1 COPYRIGHT
  898.  
  899. Copyright 1996-2003, Gisle Aas
  900.  
  901. This library is free software; you can redistribute it and/or
  902. modify it under the same terms as Perl itself.
  903.  
  904.